(** Module TransformPredicates contains:
 *  - function, which transforms predicates 
 *    (new rule with inherited parameters and special action code
 *    is created for each predicate)
 *
 *  Author: Ilia
 *)

open IL
open Production
open Namer
open TransformAux

open Misc
open Generation
open Diagnostics

let addComma s x = let s' = getText x in 
    if s = "" then s' else sprintf "%s,%s" s s'

let concatWithComma str = function
    | None   -> str
    | Some p -> addComma str p

let createTuple leftBindings binding =
    let leftBindings' = List.fold_left (addComma) "" leftBindings in 
    sprintf "(%s)" (concatWithComma leftBindings' binding)

let createChecker binding check =
    let chkText = sprintf "let %s = %s in %s " binding getKeepParamName check
    in Some (createSource chkText)

let setCheckerToFirstItem chk = function
    | h::t -> { h with Production.checker = chk }::t
    | _    -> reportError "during predicates transforming" ; []

let createPredicateBoby items binding b elem =
    let checker' = createChecker binding (genOptText elem.checker) in
    let action = Some (createSource binding) in
    if items = [] 
    then 
      let elem' = { elem with Production.checker = checker' 
                  ; Production.rule = b
                  } 
      in PSeq ([elem'], action)
    else
      let elem' = { elem with Production.checker = None
                  ; Production.rule = b
                  } 
      in 
      let items' = setCheckerToFirstItem checker' items in       
      PSeq (items' @ [elem'], action)


let processPredicate items params b e = 
    let ruleName = createNewName (createSource Names.predicate) in
    let predicateRef = PRef (ruleName, None) in
    let bind = createTuple params e.binding in
    let newRule = createSimpleRule (getText ruleName) [] 
                                   (createPredicateBoby items bind b e) 
    in (Some (createSource bind), predicateRef, newRule)

let rec processBody params (** left bindings     *)
                    rs     (** new created rules *)
    = function
    | POpt r  -> let (r', rs') = processBody params rs r in (POpt  r', rs')
    | PSome r -> let (r', rs') = processBody params rs r in (PSome r', rs')
    | PMany r -> let (r', rs') = processBody params rs r in (PMany r', rs')
    | PSeq (seq, a) -> 
      let processElem items paramList e = 
        let (b, rs') = processBody [](*paramList*) [] e.rule 
        in 
        if e.checker <> None then (
          let (bind, b', r') = processPredicate items paramList b e in
          let e' = { e with Production.binding = bind
                   ; Production.rule = b'
                   ; Production.checker = None 
                   }
          in ([e'], r'::rs')
        ) else (items @ [{ e with Production.rule = b }], rs')
      in let rec processSeq items' params' rs' = function
         | []   -> (items', rs')
         | h::t -> let params'' = addBinding params' h.binding in
           let (items'', rs'') = processElem items' params' h 
           in processSeq items'' params'' (rs' @ rs'') t 
         in let (seq', nr) = processSeq [] params [] seq
            in (PSeq (seq', a), rs @ nr)
    | PAlt (l, r) -> 
      let (l', rs') = processBody params rs l in
      let (r', rs'') = processBody params rs' r 
      in (PAlt (l', r'), rs'')
    (* do nothing in other case *)
    | other -> (other, rs)

let processRule r =
    let (b, rules) = processBody [] [] r.Rule.body 
    in rules @ [ { r with Rule.body = b } ]

(** replace predicates with references to new rules *)
let transformPredicates gr =
    List.map (processRule) gr ++ List.concat

(* (* old version, but may be need in the future *)
open IL
open Production
open Namer
open TransformAux

open Misc
open Generation
open Diagnostics

let insertCommas = function
    | []   -> ""
    | h::_ -> (** list must contain only one element *)
      Str.global_replace (Str.regexp " ") "," (getText h)

let concatWithComma str = function
    | None   -> str
    | Some p -> let s = getText p in
      if str = "" then s else sprintf "%s,%s" str s

let createTuple ruleArgs binding =
    let args = insertCommas ruleArgs in 
    sprintf "(%s)" (concatWithComma args binding)

let createChecker binding check =
    let chkText = sprintf "let %s = %s in %s " binding getKeepParamName check
    in Some (createSource chkText)

let createPredicateBoby binding b elem =
    let checker' = createChecker binding (genOptText elem.checker) in
    let elem' = { elem with Production.checker = checker' 
                ; Production.rule = b
                } 
    in let action = Some (createSource binding) in
    PSeq ([elem'], action)

let processPredicate params b e = 
    let ruleName = createNewName (createSource Names.predicate) in
    let ruleArgs = createParams params in
    let predicateRef = PRef (ruleName, createOpt ruleArgs) in
    let bind = createTuple ruleArgs e.binding in
    let newRule = createSimpleRule (getText ruleName) ruleArgs 
                                   (createPredicateBoby bind b e) 
    in (Some (createSource bind), predicateRef, newRule)

let rec processBody params (** rule parameters and left bindings *)
                    rs     (** new created rules                 *)
    = function
    | POpt r  -> let (r', rs') = processBody params rs r in (POpt  r', rs')
    | PSome r -> let (r', rs') = processBody params rs r in (PSome r', rs')
    | PMany r -> let (r', rs') = processBody params rs r in (PMany r', rs')
    | PSeq (seq, a) -> 
      let processElem paramList e = 
        let (b, rs') = processBody paramList [] e.rule 
        in 
        if e.checker <> None then (
          let (bind, b', r') = processPredicate params b e in
          let e' = { e with Production.binding = bind
                   ; Production.rule = b'
                   ; Production.checker = None 
                   }
          in (e', r'::rs')
        ) else ({ e with Production.rule = b }, rs')
      in let rec processSeq params' = function
         | []   -> ([], [])
         | h::t -> let params'' = addBinding params' h.binding in
           let (e', rs') = processElem params' h in 
           let (l', rs'') = processSeq params'' t 
           in (e'::l', rs' @ rs'')
         in let (seq', nr) = processSeq params seq
            in (PSeq (seq', a), rs @ nr)
    | PAlt (l, r) -> 
      let (l', rs') = processBody params rs l in
      let (r', rs'') = processBody params rs' r 
      in (PAlt (l', r'), rs'')
    (* do nothing in other case *)
    | other -> (other, rs)

let processRule r =
    let (b, rules) = processBody r.Rule.args [] r.Rule.body 
    in rules @ [ { r with Rule.body = b } ]

(** replace predicates with references to new rules *)
let transformPredicates gr =
    List.map (processRule) gr ++ List.concat
*)
